perm filename EPAR3B.2[EAL,HE] blob
sn#706567 filedate 1983-04-21 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00005 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00002 00002 {$NOMAIN Editor: Aux parser routines }
C00006 00003 (* reFormatStmnt *)
C00008 00004 (* idGet & ePlistParse *)
C00015 00005 (* labelParse & clabelParse *)
C00021 ENDMK
C⊗;
{$NOMAIN Editor: Aux parser routines }
%include eparse.hdr;
{ Externally defined routines from elsewhere: }
(* From ALLOC *)
function newNode: nodep; external;
procedure relNode(n: nodep); external;
function newIdent: identp; external;
procedure relIdent(n: identp); external;
procedure relStrng(n: strngp); external;
(* From EROOT: Inter-overlay calls *)
function e3bExprParse: nodep; external;
(* From EAUX1A *)
function eqStrng(s1: strngp; s2,len: integer): boolean; external;
(* From EAUX1B *)
function checkArg(n: nodep; d: datatypes): nodep; external;
(* From EAUX1C *)
procedure errprnt; external;
procedure relExpr(n: nodep); external;
procedure getDelim(char: ascii); external;
function evalOrder(what,last: nodep; pcons: boolean): nodep; external;
(* From EPUT *)
function getExprLength(n: nodep): integer; external;
(* From EEXPED *)
function exprEditor(line,lstart,llength,estart: integer;
var elength: integer; off: integer): ascii; external;
(* From EAUX2C *)
procedure deleteLines(start,number,coff: integer); external;
procedure insertLines(start,number,coff: integer); external;
(* From EPUTST *)
procedure putstmnt(s: statementp; indent, plevel: integer); external;
(* From ETOKEN *)
procedure getToken; external;
(* From PP *)
procedure relLine(l: linerecp); external;
procedure ppLine; external;
procedure ppOutNow; external;
procedure ppChar(ch: ascii); external;
procedure pp5(ch: c5str; length: integer); external;
procedure pp10(ch: cstring; length: integer); external;
procedure pp10L(ch: cstring; length: integer); external;
procedure pp20(ch: c20str; length: integer); external;
procedure pp20L(ch: c20str; length: integer); external;
procedure ppInt(i: integer); external;
procedure ppReal(r: real); external;
procedure ppStrng(length: integer; s: strngp); external;
procedure ppDtype(d: datatypes); external;
procedure ppDelChar; external;
procedure ePar3bGet; external;
procedure ePar3bGet; begin end;
(* reFormatStmnt *)
procedure reFormatStmnt(st: statementp; indent,ocur: integer); external;
procedure reFormatStmnt;
var i,j: integer;
begin
with st↑ do
begin
curLine := 1;
setUp := true;
setCursor := false;
j := nlines; (* how long were we *)
putStmnt(st,indent,99); (* possibly reformat us *)
setUp := false;
if j <> nlines then
begin (* if necessary correct for any change in nlines *)
if j < nlines then insertLines(ocur,nlines-j,1) (* fix up screen *)
else if j > nlines then deleteLines(ocur,j-nlines,1);
end;
firstLine := cursorStack[cursor].cline;
lastLine := firstLine + nlines - 1;
end;
if firstline < topDLine then firstLine := topDline;
if botDline < lastLine then
if botDline > topDline + firstDline + dispHeight - 2 then
lastLine := botDline (* it's definitely off screen *)
else botDline := lastLine; (* should be ok.... *)
for i := firstLine - topDline + 1 to lastLine - topDline + 1 do
begin (* flush old lines before redrawing stmnt *)
relLine(lines[i]);
lines[i] := nil;
end;
setCursor := true; (* let putStmnt figure right fieldnum *)
curLine := 0;
putStmnt(dProg,0,99); (* redraw statement *)
setCursor := false;
end;
(* idGet & ePlistParse *)
function idGet(st: statementp; indent,l: integer): ascii; external;
function idGet;
var id1,id2: identp; b: boolean; i,elen: integer; strg,strp: strngp;
sp: statementp; ch: ascii;
function getBlkId: identp; (* copied from EAUX3C *)
var bid: identp;
begin
bid := nil;
if curchar + 2 < maxchar then
begin
getToken; (* get the new block id *)
with curToken do
if ttype = constype then
begin
if cons↑.ltype = strngtype then
begin (* yup - grab the id string *)
bid := newIdent;
bid↑.length := cons↑.length;
bid↑.name := cons↑.str;
end
else
begin
pp20L(' Need a string here ',19); errprnt;
end;
relNode(cons);
end
else backup := true;
end;
getBlkId := bid;
end;
begin
with st↑ do
begin
if stype = coblocktype then
begin i := indent + 8; id1 := cblkid end
else
begin
if stype = endtype then i := indent + 4
else i := indent + 6;
id1 := blkid;
end;
if id1 = nil then elen := 0
else
begin
i := i + 1;
elen := id1↑.length;
strg := id1↑.name;
while strg <> nil do (* release old string *)
begin strp := strg↑.next; relStrng(strg); strg := strp end;
end;
if l > 0 then (* so addStmnt can use this *)
with lines[l]↑ do (* go edit it *)
ch := exprEditor(l-firstDline+1,start,length,i,elen,0)
else begin i := curChar + 1; elen := 1 end;
if id1 <> nil then
begin
curChar := i - 1;
maxChar := maxChar + 1;
relIdent(id1);
id1 := nil;
end;
if elen > 0 then id1 := getBlkId; (* get the new block id *)
if stype = coblocktype then
begin
cblkid := id1;
id2 := threads↑.cstmnt↑.next↑.blkid;
end
else
begin
blkid := id1;
if stype = blocktype then
begin
sp := bcode;
while sp↑.next <> nil do sp := sp↑.next; (* move to END *)
id2 := sp↑.blkid;
end
else id2 := bparent↑.blkid;
end;
if (id1 <> nil) and (id2 <> nil) then
begin (* now compare the two ids *)
b := id1↑.length = id2↑.length;
i := 3;
while listing[i] <> '"' do i := i + 1;
if b then b := eqStrng(id2↑.name,i+1,id1↑.length);
if not b then
begin
pp20L(' Block ids do not ma',20); pp5('tch ',3); errPrnt;
end;
end;
end;
idGet := ch;
end;
function plistParse(st: statementp; e0,indent,l,ocur: integer): ascii; external;
function plistParse;
var i,j,elen: integer; n,no,np: nodep; b,bp: boolean; ch: ascii;
begin
if fieldNum > 1 then
begin
no := st↑.plist;
for i := 1 to fieldNum-2 do no := no↑.next;
n := no↑.next
end
else
begin
n := st↑.plist;
if n = nil then e0 := e0 - 1;
no := nil
end;
b := true;
bp := false;
np := nil;
i := e0;
while b and (n <> nil) do
begin
j := i + getExprLength(n↑.lval);
if bp and (j > 78) then b := false
else
begin
bp := true;
np := n↑.next;
if np = nil then i := j else i := j+1; (* account for "," *)
relExpr(n↑.lval); (* flush the old expression *)
relNode(n); (* & the plist node too *)
n := np;
end
end;
elen := i - e0;
with lines[l]↑ do
ch := exprEditor(l-firstDline+1,start,length,e0,elen,0);
repeat
n := newNode;
n↑.ntype := listnode;
n↑.lval := e3bExprParse; (* parse the modified exprs *)
if n↑.lval <> nil then
begin
if no = nil then st↑.plist := n else no↑.next := n;
no := n;
end
else relNode(n);
b := false;
getToken; (* check for "," or ")" *)
with curToken do (* *** should be smarter *** *)
begin
b := (ttype <> delimtype) or (ch <> ',');
if b and ((ttype = identtype) or
((ttype = reswdtype) and (rtype = optype))) then
begin
pp20L(' Inserting missing c',20); pp5('omma ',4); errPrnt;
backUp := true;
b := false;
end;
end;
until endOfLine or b;
if no = nil then st↑.plist := np else no↑.next := np;
with st↑ do
if plist = nil then exprs := nil else exprs := evalOrder(plist,nil,false);
reFormatStmnt(st,indent,ocur); (* may have changed nlines *)
plistParse := ch;
end;
(* labelParse & clabelParse *)
procedure labelParse; external;
procedure labelParse;
var i: integer;
begin
cursorStack[cursor].st↑.stlab↑.s := nil; (* old label no longer points here *)
getToken; (* get new label *)
with curToken, cursorStack[cursor] do
if ttype = labeldeftype then
begin
st↑.stlab := lab;
lab↑.s := st;
end
else
begin (* delete the old label *)
st↑.stlab := nil;
deleteLines(cursorLine,1,0);
if (ttype <> delimtype) or (ch <> chr(15B)) or not endOfLine then
begin pp20L(' Expecting a label h',20); pp5('ere ',3); errprnt end;
end;
end;
procedure clabelParse(n: nodep); external;
procedure clabelParse;
var np: nodep;
begin
getToken;
with n↑, curToken do
if (ttype = delimtype) and (ch = '[') then
begin
np := checkArg(e3bExprParse,svaltype); (* get constant value *)
if np↑.ntype <> leafnode then
begin
pp20L(' Must have constant ',20); pp5('here ',4); errPrnt;
cval := -2;
end
else cval := round(np↑.s);
relExpr(np);
with cursorStack[cursor-1].st↑ do
if cval > -range then range := -cval;
getDelim(']');
end
else if (ttype = reswdtype) and (rtype = filtype) and
(filler = elsetype) then cval := -1
else
begin
(* *** maybe should recognize null line & delete the old label *** *)
pp20L(' Need a case number ',20); pp5('here.',5); errPrnt;
cval := -2; (* use a garbage one *)
end
end;